home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Src / slib.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-07-21  |  10.0 KB  |  392 lines
  1. /*
  2.  * s l i b . c                -- Misc functions
  3.  *
  4.  * Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  5.  * 
  6.  *
  7.  * Permission to use, copy, and/or distribute this software and its
  8.  * documentation for any purpose and without fee is hereby granted, provided
  9.  * that both the above copyright notice and this permission notice appear in
  10.  * all copies and derived works.  Fees for distribution or use of this
  11.  * software or derived works may only be charged with express written
  12.  * permission of the copyright holder.  
  13.  * This software is provided ``as is'' without express or implied warranty.
  14.  *
  15.  * This software is a derivative work of other copyrighted softwares; the
  16.  * copyright notices of these softwares are placed in the file COPYRIGHTS
  17.  *
  18.  *           Author: Erick Gallesio [eg@unice.fr]
  19.  *    Creation date: ??-Oct-1993 ??:?? 
  20.  * Last file update: 21-Jul-1996 12:54
  21.  *
  22.  */
  23.  
  24. #ifdef WIN32
  25. #  include <windows.h>
  26. #endif
  27.  
  28. #include "stk.h"
  29. #include "gc.h"
  30. #include <sys/types.h>
  31. #include <sys/stat.h>
  32.  
  33. #ifdef WIN32
  34. #   include <time.h>
  35. #   include <dos.h>
  36. #   include <process.h>
  37. #else
  38. #   include <stdarg.h>
  39. #   include <sys/times.h>
  40. #endif
  41.  
  42. #ifdef USE_TK
  43. #   include "tk-glue.h"
  44. #endif
  45.  
  46.  
  47.  
  48. #ifndef _DEBUG_MALLOC_INC
  49.  
  50. #ifdef malloc
  51. #undef malloc
  52. #endif
  53.  
  54. #ifdef realloc
  55. #undef realloc
  56. #endif
  57.  
  58. #define MAX_MALLOC_BEFORE_GC 1<<20    /* 1 Mb should suffice before calling GC */
  59.  
  60. static unsigned long malloc_count = 0;
  61.  
  62. void *STk_must_malloc(unsigned long size)
  63. {
  64.  
  65.   void *tmp;
  66.  
  67.   tmp = (void *) malloc(size);
  68.  
  69.   /* Test for size because some libc return NULL when doing malloc(0) */
  70.   if (tmp == NULL && size)
  71.     Err("failed to allocate storage from system", NIL);
  72.  
  73.   /* Idea of malloc limitation comes from Harvey J. Stein 
  74.    * <hjstein@MATH.HUJI.AC.IL>. The following code provoke a GC when
  75.    * MAX_MALLOC_BEFORE_GC have been allocated by must_malloc. This 
  76.    * allows to GC before all cells have been exhausted 
  77.    */
  78.   malloc_count +=size;
  79.   if (malloc_count > MAX_MALLOC_BEFORE_GC) {
  80.     malloc_count     = 0;
  81.     STk_gc_requested = 1;
  82.   }
  83.  
  84.   return tmp;
  85. }
  86.  
  87. void *STk_must_realloc(void *ptr, unsigned long size)
  88. {
  89.   void *tmp;
  90.  
  91.   tmp = (void *) realloc(ptr, size);
  92.   /* Since we cannot know (in a portable way) the size of area pointed by ptr,
  93.    * we will make the assumption that it is half the new requested size. 
  94.    * Of course, we are probably false here, but it seems more reasonable than 
  95.    * brutally increment it with size. 
  96.    */
  97.   malloc_count +=size/2;
  98.   if (malloc_count > MAX_MALLOC_BEFORE_GC) {
  99.     malloc_count     = 0;
  100.     STk_gc_requested = 1;
  101.   }
  102.  
  103.   if (tmp == NULL)
  104.     Err("failed to re-allocate storage from system",NIL);
  105.   return tmp;
  106. }
  107. #endif
  108.  
  109.  
  110. SCM STk_internal_eval_string(char *s, long context, SCM env)
  111. {
  112.   jmp_buf jb, *prev_jb = Top_jmp_buf;
  113.   long prev_context     = Error_context;
  114.   SCM result, port;
  115.   int k;
  116.   
  117.   /* Create a string port to read the command and evaluate it in a new context */
  118.   port = STk_internal_open_input_string(s);
  119.  
  120.   /* save normal error jmpbuf  so that eval error don't lead to toplevel */
  121.   /* If in a "catch", keep the ERR_IGNORED bit set */
  122.   if ((k = setjmp(jb)) == 0) {
  123.     Top_jmp_buf   = &jb;
  124.     Error_context = (Error_context & ERR_IGNORED) | context;
  125.     result = STk_eval(STk_readf(PORT_FILE(port), FALSE), env);
  126.   }
  127.   Top_jmp_buf   = prev_jb;;
  128.   Error_context = prev_context;
  129.  
  130.   if (k == 0) return result;
  131.   /* if we are here, an error has occured during the string reading 
  132.    * Two cases:
  133.    *    - we are in a catch. Do a longjump to the catch to signal it a fail
  134.    *    - otherwise error has already signaled, just return EVAL_ERROR
  135.    */
  136.   if (Error_context & ERR_IGNORED) longjmp(*Top_jmp_buf, k);
  137.   return EVAL_ERROR;
  138. }
  139.  
  140.  
  141. PRIMITIVE STk_catch(SCM expr, SCM env, int unused_len)
  142. {
  143.   jmp_buf jb, *prev_jb = Top_jmp_buf;
  144.   long prev_context     = Error_context;
  145.   SCM l;
  146.   int k;
  147.   
  148.   /* save normal error jmpbuf  so that eval error don't lead to toplevel */
  149.   if ((k = setjmp(jb)) == 0) {
  150.     Top_jmp_buf   = &jb;
  151.     Error_context |= ERR_IGNORED;
  152.  
  153.     /* Evaluate the list of expressions */
  154.     for (l = expr; NNULLP(l); l = CDR(l)) 
  155.       STk_eval(CAR(l), env);
  156.   }
  157.   Top_jmp_buf   = prev_jb;
  158.   Error_context = prev_context; /* Don't use a mask to allow nested call to catch */
  159.  
  160.   return (k == 0)? Ntruth: Truth;
  161. }
  162.  
  163. PRIMITIVE STk_quit_interpreter(SCM retcode)
  164. {
  165.   long ret = 0;
  166.  
  167.   if (retcode != UNBOUND) {
  168.     if ((ret=STk_integer_value(retcode)) == LONG_MIN)
  169.       Err("quit: bad return code", retcode);
  170.   }
  171.   STk_unwind_all();
  172.  
  173.   /* call user finalization code */
  174.   STk_user_cleanup();
  175. #ifdef USE_TK
  176.   Tcl_DeleteInterp(STk_main_interp); /* Unregister the interpreter from X server */
  177. #endif
  178.   exit(ret);
  179. }
  180.  
  181. PRIMITIVE STk_version(void)
  182. {
  183.   return STk_makestring(STK_VERSION);
  184. }
  185.  
  186. PRIMITIVE STk_machine_type(void)
  187. {
  188.   return STk_makestring(MACHINE);
  189. }
  190.  
  191. PRIMITIVE STk_library_location(void)
  192. {
  193.    return STk_makestring(STk_library_path);
  194. }
  195.  
  196. PRIMITIVE STk_random(SCM n)
  197. {
  198.   if (NEXACTP(n) || STk_negativep(n) == Truth || STk_zerop(n) == Truth)
  199.     Err("random: bad number", n);
  200.   return STk_modulo(STk_makeinteger(rand()), n);
  201. }
  202.  
  203. PRIMITIVE STk_set_random_seed(SCM n)
  204. {
  205.   if (NEXACTP(n)) Err("set-random-seed!: bad number", n);
  206.   srand(STk_integer_value_no_overflow(n));
  207.   return UNDEFINED;
  208. }
  209.  
  210. #ifndef HZ
  211. #define HZ 60.0
  212. #endif
  213.  
  214. #ifdef CLOCKS_PER_SEC
  215. #  define TIC CLOCKS_PER_SEC
  216. #else 
  217. #  define TIC HZ
  218. #endif
  219.  
  220. double STk_my_time(void)
  221. {
  222. #ifdef WIN32
  223.   return (long) 1000*(clock()/CLK_TCK);
  224. #else
  225.   struct tms time_buffer;
  226.   times(&time_buffer);
  227.   return 1000 * (time_buffer.tms_utime + time_buffer.tms_stime) / TIC;
  228. #endif
  229. }
  230.  
  231.  
  232. PRIMITIVE STk_get_internal_info(void)
  233. {
  234.   SCM z = STk_makevect(7, NULL);
  235.   long allocated, used, calls;
  236.  
  237.   /* The result is a vector which contains
  238.    *    0 The total cpu used in ms
  239.    *    1 The number of cells currently in use.
  240.    *    2 Total number of allocated cells
  241.    *    3 The number of cells used since the last call to get-internal-info
  242.    *    4 Number of gc calls
  243.    *    5 Total time used in the gc
  244.    *    6 A boolean indicating if Tk is initialized
  245.    */
  246.  
  247.   STk_gc_count_cells(&allocated, &used, &calls);
  248.  
  249.   VECT(z)[0] = STk_makenumber(STk_my_time());
  250.   VECT(z)[1] = STk_makeinteger(used);
  251.   VECT(z)[2] = STk_makeinteger(allocated);
  252.   VECT(z)[3] = STk_makenumber((double) STk_alloc_cells);
  253.   VECT(z)[4] = STk_makeinteger(calls);
  254.   VECT(z)[5] = STk_makenumber((double) STk_total_gc_time);
  255. #ifdef USE_TK
  256.   VECT(z)[6] = Tk_initialized ? Truth: Ntruth;
  257. #else
  258.   VECT(z)[6] = Ntruth;
  259. #endif
  260.   
  261.   STk_alloc_cells = 0;
  262.   return z;
  263. }
  264.  
  265.  
  266. PRIMITIVE STk_time(SCM expr, SCM env, int len)
  267. {
  268.   double rt, gc_time;
  269.   SCM res;
  270.  
  271.   if (len != 1) Err("time: bad expression" , expr);
  272.  
  273.   STk_alloc_cells = 0;
  274.   gc_time         = STk_total_gc_time;
  275.   rt               = STk_my_time();
  276.   res               = EVALCAR(expr);
  277.   fprintf(STk_stderr, ";;    Time: %.2fms\n;; GC time: %.2fms\n;;   Cells: %ld\n",
  278.       STk_my_time()-rt, STk_total_gc_time-gc_time, STk_alloc_cells);
  279.   return res;
  280. }
  281.  
  282.  
  283. /* When STk evaluates an expression, it recodes it in a manner which permits it
  284.    to be more efficient for further evaluations. The uncode functions permits to 
  285.    do the reverse job: it takes an exppression and returns a form similar to the 
  286.    original one. 
  287.    Warning: when a macro has been expanded, there is no mean to "revert" it to 
  288.    its original form 
  289. */
  290.  
  291.  
  292. static SCM associate(SCM l1, SCM l2)
  293. {
  294.   SCM z;
  295.  
  296.   if (NULLP(l1)) return NIL;
  297.   
  298.   for(z= NIL; NNULLP(l1); l1=CDR(l1), l2=CDR(l2))
  299.     z = Cons(LIST2(CAR(l1), STk_uncode(CAR(l2))), z);
  300.   
  301.   return Reverse(z);
  302. }
  303.  
  304. static SCM uncode_let(char *type, SCM expr)
  305. {
  306.   return Cons(Intern(type),
  307.           Cons(associate(CAR(expr), CAR(CDR(expr))),
  308.            STk_uncode(CDR(CDR(expr)))));
  309. }
  310.   
  311. PRIMITIVE STk_uncode(SCM expr)
  312. {
  313.   switch (TYPE(expr)) {
  314.     case tc_cons: switch (TYPE(CAR(expr))) {
  315.                 case tc_let:     return uncode_let("let",    CDR(expr)); 
  316.                   case tc_letstar: return uncode_let("let*",   CDR(expr)); 
  317.             case tc_letrec:  return uncode_let("letrec", CDR(expr)); 
  318.             case tc_if: 
  319.                  expr = CDR(expr);
  320.                  if (EQ(CAR(CDR(CDR(expr))), UNDEFINED)) 
  321.                return Cons(Intern("if"),
  322.                        LIST2(STk_uncode(CAR(expr)),
  323.                          STk_uncode(CAR(CDR(expr)))));
  324.              else
  325.                return Cons(Intern("if"),
  326.                        LIST3(STk_uncode(CAR(expr)),
  327.                          STk_uncode(CAR(CDR(expr))),
  328.                          STk_uncode(CAR(CDR(CDR(expr))))));
  329.             default: return Cons(STk_uncode(CAR(expr)),
  330.                      STk_uncode(CDR(expr)));
  331.           }
  332.     case tc_quote:    return Intern("quote");
  333.     case tc_lambda:    return Intern("lambda");
  334.     case tc_if:        return Intern("if");
  335.     case tc_setq:    return Intern("set!");
  336.     case tc_cond:    return Intern("cond");
  337.     case tc_and:    return Intern("and");
  338.     case tc_or:        return Intern("or");
  339.     case tc_let:    return Intern("let");
  340.     case tc_letstar:    return Intern("letstar");
  341.     case tc_letrec:     return Intern("letrec");
  342.     case tc_begin:    return Intern("begin");
  343.     case tc_globalvar:  return VCELL(expr);
  344.     case tc_localvar:   return expr->storage_as.localvar.symbol;
  345.     case tc_apply:    return Intern("apply");
  346.     case tc_call_cc:    return Intern("call-with-current-continuation");
  347.     case tc_dynwind:    return Intern("dynamic-wind");
  348.     case tc_extend_env: return Intern("extend-environment");
  349.     default:        return expr;
  350.   }
  351. }
  352.  
  353. /* 
  354.  * A Panic procedure.
  355.  */
  356. void STk_panic TCL_VARARGS_DEF(char *,arg1)
  357. {
  358.   va_list argList;
  359.   char buf[1024];
  360.   char *format;
  361.      
  362.   format = TCL_VARARGS_START(char *,arg1,argList);
  363.   vsprintf(buf, format, argList);
  364.  
  365. #ifdef WIN32
  366.   MessageBeep(MB_ICONEXCLAMATION);
  367.   MessageBox(NULL, buf, "Fatal error in STk", 
  368.          MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND);
  369. #else
  370.   fprintf(STk_stderr, "\n**** %s\n", buf);
  371.   fflush(STk_stderr);
  372. #endif
  373.   exit(1);
  374. }
  375.  
  376.  
  377. /******************************************************************************
  378.  *
  379.  * The following declarations serve only for referencing symbols which are used
  380.  * by Tcl or Tk and which are defined in this directory. Otherwise, the ld will
  381.  * not find them and report an error
  382.  *
  383.  ******************************************************************************/
  384. #ifndef WIN32
  385. typedef void (*dumb)();
  386.  
  387. dumb STk_dumb[] = { 
  388.   (dumb) Tcl_TildeSubst,
  389.   (dumb) Tcl_SetVar2
  390. };
  391. #endif
  392.